Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/PASCAL/0189.ZIP/TRANSFER.PAS

Pascal/Delphi Source File | 1986-02-09 | 28KB | 787 lines

(***************************************************************)
(*                                                             *)
(*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
(*                                                             *)
(*        (C) 1985 by  John M. Harlan                          *)
(*                     24000 Telegraph                         *)
(*                     Southfield, MI. 48034                   *)
(*                                                             *)
(*     The FILER GROUP of programs is released on a "FREE      *)
(*     SOFTWARE" basis.  The recipient is free to examine      *)
(*     and use the software with the understanding that if     *)
(*     the FILER GROUP of programs prove to be of use and      *)
(*     value,  a contribution to the author is encouraged.     *)
(*                                                             *)
(*     While reasonable effort has been made to ensure the     *)
(*     reliability of the FILER GROUP of programs, no war-     *)
(*     ranty is given. The recipient uses the programs at      *)
(*     his own risk  and in no event shall the author be       *)
(*     liable for damages arising from their use.              *)
(*                                                             *)
(*                                                             *)
(***************************************************************)


program transfer;  { ONE OF THE FILER GROUP OF PROGRAMS }
{  PROGRAM TO TRANSFER DATA FROM ONE FILER DATA FORMAT  }
{  TO A SECOND FILER DATA FORMAT                        }
{  TRANSFER.PAS  REVISION 2.0 }
{  INCLUDE FILES : TRANSFR1.PAS }
{  JUNE 24, 1985 }

{ Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  editors global search/replace. Original version was 100%
  upper case and very hard to read. }

label  QUIT;

type
  Range            = array[1..256] of char;
  String60         =  string[60];
  String20         =  string[20];
  NameStr          =  string[12];

var
  filerecchgd      : boolean;    { FOR SOURCE FILE }
  recaddedtofile   : boolean;    { FOR SOURCE FILE }
  filerecchgd2     : boolean;    { FOR DESTINATION FILE }
  recaddedtofile2  : boolean;    { FOR DESTINATION FILE }
  fileexists       : boolean;
  nullrecord       : boolean;
  exitflag         : boolean;

  ch               : char;

  filename,filename2         : string[6];
  filedate,filedate2,
  currdate                   : string[8];
  sourcename                 : string[14];
  sourcenamedat              : string[14];
  destinationname            : string[14];
  destinationnamedat         : string[14];

  ans                        : String60;
  message                    : String60;
  thiskey                    : String60;

   w, x, y, z, code, first, len,
  maxnbrrec, rcdlen, destfieldnbr,
  blockingfactor, fieldperrecord,
  ascii, keylength, destnbr             : integer;

  w2, x2, y2, z2, code2, first2, len2,
  maxnbrrec2, rcdlen2,
  blockingfactor2, fieldperrecord2,
  ascii2, keylength2                    : integer;

  datarecord, diskrecord, precbyte,
  diskrecnowinmem, nbrdiskrecused,
  nbrrecused,lastrecused                : integer;  { FOR SOURCE FILE }

  datarecord2, diskrecord2, precbyte2,
  diskrecnowinmem2, nbrdiskrecused2,
  nbrrecused2,lastrecused2              : integer;  { FOR DESTINATION FILE }

  numvalue                              :    real;

  labellength, datalen, dataform,
  labelposn, dataposn, row, column      :    array[1..32] of integer;

  labellength2, datalen2, dataform2,
  labelposn2, dataposn2, row2,
  column2, transarray                   :    array[1..32] of integer;

  keyfield                              :    array[0..10] of integer;
  lbl,lbl2                              :    array[1..384] of char;
  getdata                               :    Range;  { FOR SOURCE FILE }
  getdata2                              :    Range;  { FOR DESTINATION FILE }

  source                                :    file;
  destination                           :    file;


{================================================================}
{        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
{================================================================}
function BcdToInt (cha : char) : integer;
begin
  BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
end;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
function ChrToInt(var charray : Range; start, len : integer)  : integer;
var
  code, result : integer;
  workstring   : string[10];
begin
  workstring := '';
  for result := 0 to len-1  do
    begin
      if charray[start + result ] = ' ' then
        workstring := workstring + '0'
      else workstring := workstring + charray[start+result];
    end;
  val(workstring,result,code);
  ChrToInt := result;
end;
{================================================================}
{               TIDE (EDIT BACKWARDS) PROCEDURE                  }
{================================================================}
procedure Tide( var message : String60);
var w  :  integer;
begin
  for w := length(message) downto 1 do
    begin
      if message[w] in [',', '$', '+'] then
        begin
          delete(message,w,1);
          message := ' ' + message;
        end;
    end;
end;
{===============================================================}
{                      FUNCTION EDITNBR                         }
{===============================================================}
function EditNbr(x: real; y,z: integer; dollar: char ) : String20;
var
  numstring : string[24];
begin    { CONVERT THE REAL NUMBER TO A STRING VALUE }
  str(x:18:z,numstring);
  if z = 0 then z := 16  { FIRST POSSIBLE COMMA LOCATION  }
  else z := pos('.',numstring)-3;  {    DITTO             }

  while z > 1 do  {  INSERT COMMAS/SPACES IN THE NUMBER  }
    begin
      if numstring[z-1] in [' ','-'] then
        insert(' ',numstring,z)
      else insert(',',numstring,z);
      z := z -3 ;  {  COMMAS OCCUR EVERY THIRD CHARACTER  }
    end;

  {  FIND THE FIRST NON SPACE CHARACTER IN THE NUMBER }
  z := 0;
  repeat
    z := z + 1;
 until numstring[z] <> ' ';

  { DELETE ANY SPACE FOLLOWING A MINUS SIGN }
  if numstring[z] = '-' then
    begin
      if numstring[z+1] = ' ' then delete(numstring,z+1,1);
      if dollar = '$' then insert('$',numstring,z+1);
    end

  { ADD THE $/SPACE CHARACTER TO THE BEGINNING OF THE NUMBER }
  else numstring[z-1] := dollar;

  { REPLACE THE NUMBER WITH A FIELD OF '<' IF IT IS TOO BIG  }
  z := length(numstring)-y;
  if numstring[z-1] = '-' then
      for z := y downto 0 do numstring[z] := '<'
  else
    begin
      if numstring[z] in ['0'..'9',',','-','.'] then
          for z := y downto 0 do numstring[z] := '<';
    end;
  EditNbr := copy(numstring,z+1,y);

end;
{================================================================}
{               STRING TO REAL NUMBER PROCEDURE                  }
{================================================================}
procedure StringToReal(var source:String60;var numb:real;var code:integer);
var
  w  :  integer;
  condition  :  boolean;
begin
  w := 1;
  numb := 0;
  condition := true;
  Tide(source); { ELIMINATE PUNCTUATION }
  repeat  { UNTIL CONDITION = FALSE }
    if source[w] = ' ' then delete(source,1,1)
    else condition := false;
    if length(source) = 0 then
      begin
        source := '0';
        condition := false;
      end;
  until condition = false;
  if length(source) = 1 then condition := true;
  while condition = false do
    begin
      if source[w] = ' ' then
        begin
          condition := true;
          w := w-2;
        end;
      if length(source) = w then
        begin
          condition := true;
          w := w-1;
        end;
      w := w + 1;
    end;
  source := copy(source,1,w);
  val( source,numb,code );
end;
{================================================================}
{           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
{================================================================}
procedure Calculate;
  begin
    diskrecord := trunc((datarecord-1)/blockingfactor)*2+7;
    precbyte := ((datarecord-1) mod blockingfactor)*rcdlen;
  end;
{================================================================}
{                   GET DATA RECORD PROCEDURE                    }
{================================================================}
procedure GetDataRec;
  begin
    Calculate;
    if diskrecord <> diskrecnowinmem then
      begin
        if filerecchgd = true then
          begin
            if diskrecnowinmem > nbrdiskrecused then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(source,nbrdiskrecused+2);
                nbrdiskrecused := diskrecnowinmem;
              end
            else
              begin
                Seek(source,diskrecnowinmem);
              end;
            blockwrite(source,getdata,2);  {SAVE CHANGED DATA}
            filerecchgd := false;
          end;
        if diskrecord <= nbrdiskrecused then
          begin
            Seek(source,diskrecord);
            blockread(source,getdata,2);         {  RECORD DATA  }
          end
        else FillChar(getdata[1],256,' '); {SPACES FOR EMPTY REC }
        diskrecnowinmem := diskrecord;
      end;
  end;
{================================================================}
{     CALCULATE DESTINATION DISKRECORD & PRECBYTE PROCEDURE      }
{================================================================}
procedure Calculate2;
  begin
    diskrecord2 := trunc((datarecord2-1)/blockingfactor2)*2+7;
    precbyte2 := ((datarecord2-1) mod blockingfactor2)*rcdlen2;
  end;
{================================================================}
{            GET DESTINATION DATA RECORD PROCEDURE               }
{================================================================}
procedure GetDataRec2;
  begin
    Calculate2;
    if diskrecord2 <> diskrecnowinmem2 then
      begin
        if filerecchgd2 = true then
          begin
            if diskrecnowinmem2 > nbrdiskrecused2 then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(destination,nbrdiskrecused2+2);
                nbrdiskrecused2 := diskrecnowinmem2;
              end
            else
              begin
                Seek(destination,diskrecnowinmem2);
              end;
            blockwrite(destination,getdata2,2);  {SAVE CHANGED DATA}
            filerecchgd2 := false;
          end;
        if diskrecord2 <= nbrdiskrecused2 then
          begin
            Seek(destination,diskrecord2);
            blockread(destination,getdata2,2);         {  RECORD DATA  }
          end
        else FillChar(getdata2[1],256,' '); {SPACES FOR EMPTY REC }
        diskrecnowinmem2 := diskrecord2;
      end;
  end;
{================================================================}
{               GET DATA FROM ARRAY PROCEDURE                    }
{================================================================}
procedure GetDataFromArray(var message : String60; z : integer);
var w :  integer;
begin
  message := '';
  for w := precbyte+dataposn[z] to precbyte+dataposn[z+1]-1 do
    message := message + getdata[w];
end;
{================================================================}
{                 PRINT LABEL AND FIELD NUMBER                   }
{================================================================}
procedure PrintLabFldNbr( z: integer);
var
  w      :  integer;
begin
  if row[z] <22 then
    begin
      GotoXY(column[z],row[z]);
      for w := labelposn[z] to labelposn[z+1]-1 do
      write (lbl[w]);
      write('= ',z);
    end;
end;
{================================================================}
{                      PRINT LABEL                               }
{================================================================}
procedure PrintLabel( z: integer);
var
  w      :  integer;
begin
  write(z,' : ');
  for w := labelposn[z] to labelposn[z+1]-1 do
  write (lbl[w]);
  writeln;
end;
{================================================================}
{              DISPLAY ONE RECORD PROCEDURE, SOURCE              }
{================================================================}
procedure DisplayRec;
begin
  ClrScr;
  for z := 1 to fieldperrecord do
  PrintLabFldNbr(z);
  GotoXY(70,23);
  write('RECORD ',datarecord);
  lastrecused := datarecord;
end;

{================================================================}
{               GET DATA FROM ARRAY2 PROCEDURE                   }
{================================================================}
procedure GetDataFromArray2(var message : String60; z : integer);
var w :  integer;
begin
  message := '';
  for w := precbyte2+dataposn2[z] to precbyte2+dataposn2[z+1]-1 do
    message := message + getdata2[w];
end;
{================================================================}
{        PRINT DESTINATION LABEL AND FIELD NUMBER                }
{================================================================}
procedure PrintLabFldNbr2( z: integer);
var
  w      :  integer;
begin
  if row2[z] <22 then
    begin
      GotoXY(column2[z],row2[z]);
      for w := labelposn2[z] to labelposn2[z+1]-1 do
      write (lbl2[w]);
      write('= ',z);
    end;
end;
{================================================================}
{                PRINT DESTINATION LABEL                         }
{================================================================}
procedure PrintLabel2( z: integer);
var
  w      :  integer;
begin
  write(z,' : ');
  for w := labelposn2[z] to labelposn2[z+1]-1 do
  write (lbl2[w]);
  writeln;
end;
{================================================================}
{           DISPLAY ONE RECORD PROCEDURE, DESTINATION            }
{================================================================}
procedure DisplayRec2;
begin
  ClrScr;
  for z := 1 to fieldperrecord2 do
  PrintLabFldNbr2(z);
  GotoXY(70,23);
  write('RECORD ',datarecord2);
  lastrecused2 := datarecord2;
end;
{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
function Exist(filename : NameStr) : boolean;
var
  fil    :  file;
  status : Integer;

begin
  Assign(fil,filename);
  {$I-}
  reset(fil);
  {$I+}
  Exist := (IOResult = 0);
{$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
end;                                        (* Added by Doug Stevens *)
{================================================================}
{           FUNCTION GET NUMBER IN GETDATA FIELD ( Z )           }
{================================================================}
function FnbrInFld(z : integer) : real;
var
  realval : real;
  begin
    GetDataFromArray(ans,z);
    if dataform[z] <> ascii then
      StringToReal(ans,realval,code)
    else realval := 0;
    FnbrInFld := realval;
  end;

{================================================================}
{            STORE DATA IN ARRAY GETDATA PROCEDURE               }
{================================================================}
procedure StoreDataInArray2 (z : integer);
begin
  first := 1;
  if dataform2[z] <> ascii then
    begin
      StringToReal(ans,numvalue,code);
      str(numvalue:20:8,ans);
      ans := ans + '                                            ';
      first := pos('.',ans) - datalen2[z];
      if dataform2[z] <> 0 then first := first + dataform2[z] + 1;
      if dataform2[z] = ascii then first := 1;
    end;
  FillChar(getdata2[precbyte2+dataposn2[z]],datalen2[z],' ');
  Move(ans[first],getdata2[precbyte2+dataposn2[z]],datalen2[z]);
end;
{================================================================}
{                  INITIALIZE FILER FILE                         }
{================================================================}
procedure Initialize;
  label  QUIT;

begin
  repeat
    ClrScr; exitflag := FALSE;
    TextMode(bw40);
    GotoXY(1,22);
    write('TRANSFER A LA PASCAL');
    GotoXY(1,23);
    write('ENTER SOURCE FILE NAME : ');
    readln(sourcename);
    x := pos('.',sourcename);
    if x <> 0 then sourcename := copy(sourcename,1,x-1);
    if sourcename = 'END' then
      begin                     { Quick and dirty exit. }
        exitflag := TRUE;
        goto QUIT;
      end;
    sourcenamedat := sourcename + '.DAT';
    fileExists := Exist(sourcenamedat);
  until fileexists = true;
  writeln;
  writeln;

  repeat
    GotoXY(1,23);
    write('ENTER DESTINATION FILE NAME : ');
    readln(destinationname);
    x := pos('.',destinationname);
    if x <> 0 then destinationname := copy(destinationname,1,x-1);
    destinationnamedat := destinationname + '.DAT';
    fileexists := exist(destinationnamedat);
  until fileexists = true;


  {=======================================}
  {   CREATE SOURCE & DESTINATION FILE    }
  {=======================================}
  Assign(source,sourcenamedat);
  reset(source);

  Assign(destination, destinationnamedat);
  reset ( destination );

  {=======================================}
  {        BUILD HEADER FOR SOURCE        }
  {=======================================}
  Seek(source,0);
  blockread( source,getdata,1 );          { BASIC/Z BLOCK 0 }
  blockread( source,getdata,1 );          { FILE PARAMETERS }
  blockread( source,lbl,3 );                 { FILER LABELS }


  {=================================================}
  {      READ IN HEADER DATA FOR FILER FILE         }
  {=================================================}
  filename := 'XXXXXX';
  for x := 1 to 6 do
    filename[x] := getdata[x];
  maxnbrrec := ChrToInt(getdata,7,4);
  nbrrecused := ChrToInt(getdata,11,4);
  rcdlen := ChrToInt(getdata,15,3);
  blockingfactor := ChrToInt(getdata,18,2);
  fieldperrecord := ChrToInt(getdata,20,2);
  filedate := '  /  /  ';
  Move(getdata[22],filedate[1],8);

{================================================================}
{  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
{================================================================}

labelposn[1] := 1;
dataposn[1] := 1;

for x := 1 to fieldperrecord do
  begin
    labellength[x] :=  BcdToInt(getdata[32+x]);
    datalen[x]     :=  BcdToInt(getdata[64+x]);
    dataform[x]    :=  ord(getdata[96+x])-48;
    labelposn[x+1] :=  labelposn[x] + labellength[x];
    dataposn[x+1]  :=  dataposn[x] + datalen[x];
  end;

{================================================================}
{           TRANSLATE REPORT STRUCTURE                           }
{================================================================}

  blockread(source,getdata,1);  { SCREEN INFORMATION }
      { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
      if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  for x := 1 to fieldperrecord do
    begin
      w := x*4+1;
      row[x]       := BcdToInt(getdata[w]);
      column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
      {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { not implemented }
    end;
  blockread(source,getdata,2);  { REPORT FORMAT INFORMATION (NOT USED) }


  {============================================}
  {        BUILD HEADER FOR DESTINATION        }
  {============================================}
  Seek(destination,0);
  blockread( destination,getdata2,1 );          { BASIC/Z BLOCK 0 }
  blockread( destination,getdata2,1 );          { FILE PARAMETERS }
  blockread( destination,lbl2,3 );                 { FILER LABELS }


  {=================================================}
  {      READ IN HEADER DATA FOR FILER FILE         }
  {=================================================}
  filename := 'XXXXXX';
  for x := 1 to 6 do
    filename2[x] := getdata2[x];
  maxnbrrec2 := ChrToInt(getdata2,7,4);
  nbrrecused2 := ChrToInt(getdata2,11,4);
  rcdlen2 := ChrToInt(getdata2,15,3);
  blockingfactor2 := ChrToInt(getdata2,18,2);
  fieldperrecord2 := ChrToInt(getdata2,20,2);
  filedate2 := '  /  /  ';
  Move(getdata2[22],filedate2[1],8);

{================================================================}
{  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
{================================================================}

labelposn2[1] := 1;
dataposn2[1] := 1;

for x := 1 to fieldperrecord2 do
  begin
    labellength2[x] :=  BcdToInt(getdata2[32+x]);
    datalen2[x]     :=  BcdToInt(getdata2[64+x]);
    dataform2[x]    :=  ord(getdata2[96+x])-48;
    labelposn2[x+1] :=  labelposn2[x] + labellength2[x];
    dataposn2[x+1]  :=  dataposn2[x] + datalen2[x];
  end;

{================================================================}
{           TRANSLATE REPORT STRUCTURE                           }
{================================================================}

  blockread(destination,getdata2,1);  { SCREEN INFORMATION }
      { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
      if getdata2[1] = 'S' then ascii := 9 else ascii := 15;
  for x := 1 to fieldperrecord2 do
    begin
      w := x*4+1;
      row2[x]       := BcdToInt(getdata2[w]);
      column2[x] := BcdToInt(getdata2[w+1])*10+trunc(BcdToInt(getdata2[w+2])/10);
      {FIELDNBR2[X]  := BCDTOIN(GETDATA2[W+3]);} { not implemented }
    end;
  blockread(destination,getdata2,2);  { REPORT FORMAT INFORMATION (NOT USED) }

{================================================================}
{          INITIALIZE VARIABLES FOR ENTRY INTO FILER             }
{================================================================}
  datarecord := nbrrecused;                 { SOURCE FILE SET UP }
  Calculate;
  diskrecnowinmem := diskrecord -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd := false;      { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused := 0;               { SET LAST RECORD USED TO ZERO }
  nbrdiskrecused := diskrecord;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile := false; { FLAG TO INDICATE CHANGE IN FILE SIZE}
{================================================================}
{        INITIALIZE VARIABLES FOR ENTRY INTO DESTINATION         }
{================================================================}
  datarecord2 := nbrrecused2;          { DESTINATION FILE SET UP }
  Calculate2;
  diskrecnowinmem2 := diskrecord2 -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd2 := false;       { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused2 := 0;                { SET LAST RECORD USED TO ZERO }
  nbrdiskrecused2 := diskrecord2;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile2 := false;  { FLAG TO INDICATE CHANGE IN FILE SIZE}
QUIT:
end;  { INTIIALIZE PROCEDURE }

{================================================================}
{                     TRANSFER PROGRAM                           }
{================================================================}

begin
  Initialize;                   { ID AND READ IN FILE PARAMETERS }
  if exitflag then goto QUIT;   { Quick and dirty exit. }
  TextMode(bw80);

  {======================================}
  {        BUILD TRANSLATE ARRAY         }
  {======================================}
  repeat
    DisplayRec2;   { DISPLAY DESTINATION FILER FILE }
    for x := 1 to 31 do
      transarray[x] := 0;
    x := 1;
    repeat
      GotoXY(1,22);
      write('NAME OF SOURCE FIELD TO BE TRANSLATED  : ');
      ClrEol;
      TextColor(yellow);
      TextBackGround(blue);
      for w := labelposn[x] to labelposn[x+1]-1 do { WRITE LABEL }
        write(lbl[w]);
      TextColor(white);
      TextBackGround(black);
      GotoXY(1,23);
      write('ENTER DESTINATION FIELD NUMBER (ABOVE) : ');
      ClrEol;
      ans := '';
      read(ans);
      if length(ans) = 0 then
        begin
          ans := '0';
        end;
      if (ans = '-') and (x>1) then x := pred(x)
      else
        begin
          val(ans,destfieldnbr,code);
          if code = 0 then
            begin
              transarray[x] := destfieldnbr;
              x := succ(x);
            end
          else transarray[x] := 0;
        end;
    until x > fieldperrecord;

    ClrScr;
    for x := 1 to fieldperrecord do
      begin
        write(x:3,'  ===>',transarray[x]:3,'   |  ');
        for w := labelposn[x] to labelposn[x+1]-1 do
              write (lbl[w]);
        write(' ===> ');
        if transarray[x] <> 0 then
          begin
            for w := labelposn2[transarray[x]] to labelposn2[transarray[x]+1]-1 do
              write(lbl2[w]);
          end;
        writeln;
      end;
    writeln;
    write('IS TRANSFER TABLE OK (Y/N) : ');
    readln(ch);
    ch := UpCase(ch);
    if ch <> 'N' then ch := 'Y';
  until ch = 'Y';
  writeln;
  write('PRINT HARD COPY OF TRANSFER TABLE (Y/N) ? : ');
  readln(ch);
  ch := UpCase(ch);
  if ch = 'Y' then
  begin
    writeln('ENERGIZE AND SELECT PRINTER FOR HARD COPY');
    writeln('DEPRESS ANY KEY WHEN READY.');
    read(Kbd,ch);
    writeln;
    writeln('..... PRINTING......');

    writeln(Lst,'             TRANSLATION TABLE');
    writeln(Lst);
    writeln(Lst,'OLD      NEW      OLD LABEL ==> NEW LABEL');
    writeln(Lst,'FLD #    FLD #');
    writeln(Lst);
    for x := 1 to fieldperrecord do
      begin
        write(Lst,x:3,'  ===>',transarray[x]:3,'   |  ');
        for w := labelposn[x] to labelposn[x+1]-1 do
              write(Lst,lbl[w]);
        write(Lst,' ===> ');
        if transarray[x] <> 0 then
          begin
            for w := labelposn2[transarray[x]] to labelposn2[transarray[x]+1]-1 do
              write(Lst,lbl2[w]);
          end;
        writeln(Lst);
      end;
    writeln(Lst,^l);
  end;

  ClrScr;
  GotoXY(1,20);
  writeln('TRANSFER A LA PASCAL');               { TRANSFER DATA }
  write('====================');
  for datarecord := 1 to nbrrecused do
    begin
      GetDataRec;    { GET SOURCE DATA RECORD }
      datarecord2 := datarecord;
      GetDataRec2;   { GET DESTINATION DATA RECORD }
      for destnbr := 1 to fieldperrecord do
        begin
          w := transarray[destnbr];
          if w <> 0 then
            begin
              GetDataFromArray(ans,destnbr);
              ans := ans + '                                     ';
              StoreDataInArray2(w);
            end;
          filerecchgd2 := true;
        end;
        GotoXY(1,23);
        write(datarecord,' OF ',nbrrecused,' RECORDS TRANSFERED.');
    end;

{================================================================}
{                    END PROGRAM                                 }
{================================================================}
if filerecchgd2 = true then  { ENSURE LAST RECORD IS WRITTEN TO DISK }
  begin
    Seek(destination,diskrecnowinmem2);
    blockwrite(destination,getdata2,2);
  end;

Seek(destination,1);                 { UPDATE NUMBER OF RECORDS }
blockread(destination,getdata2,1);

writeln;
writeln;
writeln('HAVE A GREAT DAY!');

str(nbrrecused:4,ans);                {  ENTER NUMBER OF RECORDS  }
Move(ans[1],getdata2[11],4);          { IN FILER FILE HEADER INFO }
Seek(destination,1);
blockwrite(destination,getdata2,1);

close(source);
close(destination);
QUIT:
end.